Attribute VB_Name = "Metaprogramming"
Option Explicit
'begin_line
'close
'open
'begin_path
'end_line
'stroke_colour
'fill_colour
'stroke_width
'begin_group
'end_group

Sub split_fields()
    Dim str As String
    str = "[1]" & Chr(9) & "2" & Chr(9) & "3:" & Chr(9) & "4" & Chr(9) & "[5]"
    Dim fields As Variant
    fields = Split(str, Chr(9))
    Stop
End Sub

Sub import_fields(ts, cnt As Integer, fields() As String)
    ReDim fields(cnt) As String
    Collection
    For ii = 0 To cnt - 1
        str = Mid(str, pos + 1)
        pos = InStr(1, str, Chr(9))
        fields(ii) = Left(str, pos)
    Next ii
    fields(5) = Val(Mid(str, pos + 1))
End Sub

Sub import_rgb(ts, r As Integer, g As Integer, b As Integer)
    Dim str As String
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop
    
    Dim fields As Variant
    fields = Split(str, Chr(9))
    If Not UBound(fields) = 2 Then
        MsgBox ("Warning:[" & str & "] needs to have three RGB values")
        Error 321
    End If
    r = CDbl(fields(0))
    g = CDbl(fields(1))
    b = CDbl(fields(2))
End Sub

Sub import_postscript_fill_and_apply(curr_shape As Shape, ts)
    Dim str As String
    Dim pos As Integer
            
    ' Read first none comment line
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop
    
    Dim fields As Variant
    fields = Split(str, Chr(9))
    If Not UBound(fields) = 5 Then
        MsgBox ("Warning:[" & str & "] needs to have 6 postscript fill parameters")
        Error 321
    End If
    
    
    ' postscript fill parameters
    Dim postscript_fill_parameters(5) As Integer
    Dim ii As Integer
    For ii = 0 To 3
        str = Mid(str, pos + 1)
        pos = InStr(1, str, Chr(9))
        postscript_fill_parameters(ii) = Val(Left(str, pos))
    Next ii
    postscript_fill_parameters(4) = Val(Mid(str, pos + 1))
    
    'MsgBox "postscript index " & postscript_fill_index
    'For ii = 0 To 4
    '    MsgBox "postscript parameter(" & ii & ") = " & postscript_fill_parameters(ii)
    'Next ii
    
    If Not curr_shape Is Nothing Then
        Dim pf As PostScriptFill
        Set pf = curr_shape.Fill.ApplyPostscriptFill(fields(0))
        For ii = 1 To 5
            pf.Properties(ii) = fields(ii)
        Next ii
    Else
        MsgBox ("Warning: No current Object")
    End If
End Sub

Function import_string(ts) As String
    Dim str As String
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop
    import_string = str
End Function


Function import_float(ts) As Double
    import_float = CDbl(import_string(ts))
End Function

Function import_ellipse_ltrb(ts, scaling As Double) As Shape
    ' skip past comments
    Dim str As String
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop

    Dim fields As Variant
    fields = Split(str, Chr(9))
    If Not UBound(fields) = 3 Then
        MsgBox ("Warning:[" & str & "] needs to have top left right bottom values for an ellipse")
        Error 321
    End If
    Dim t As Double, l As Double, r As Double, b As Double
    l = CDbl(fields(0)) * scaling
    t = CDbl(fields(1)) * scaling
    r = CDbl(fields(2)) * scaling
    b = CDbl(fields(3)) * scaling
    Set import_ellipse_ltrb = ActiveLayer.CreateEllipse(l, t, r, b)
End Function
Function import_ellipse_centre(ts, scaling As Double) As Shape
    ' skip past comments
    Dim str As String
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop

    Dim fields As Variant
    fields = Split(str, Chr(9))
    If Not UBound(fields) = 3 Then
        MsgBox ("Warning:[" & str & "] needs to have top left right bottom values for an ellipse")
        Error 321
    End If
    Dim x As Double, y As Double, w As Double, h As Double
    x = CDbl(fields(0)) * scaling
    y = CDbl(fields(1)) * scaling
    w = CDbl(fields(2)) * scaling
    h = CDbl(fields(3)) * scaling
    Set import_ellipse_centre = ActiveLayer.CreateEllipse2(x, y, w, h)
End Function
Function import_rect_ltrb(ts, scaling As Double) As Shape
    ' skip past comments
    Dim str As String
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop

    Dim fields As Variant
    fields = Split(str, Chr(9))
    If Not UBound(fields) = 3 Then
        MsgBox ("Warning:[" & str & "] needs to have top left right bottom values for an ellipse")
        Error 321
    End If
    Dim t As Double, l As Double, r As Double, b As Double
    l = CDbl(fields(0)) * scaling
    t = CDbl(fields(1)) * scaling
    r = CDbl(fields(2)) * scaling
    b = CDbl(fields(3)) * scaling
    Set import_rect_ltrb = ActiveLayer.CreateRectangle(l, t, r, b)
End Function
Function import_rect_centre(ts, scaling As Double) As Shape
    ' skip past comments
    Dim str As String
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop

    Dim fields As Variant
    fields = Split(str, Chr(9))
    If Not UBound(fields) = 3 Then
        MsgBox ("Warning:[" & str & "] needs to have top left right bottom values for an ellipse")
        Error 321
    End If
    Dim x As Double, y As Double, w As Double, h As Double
    x = CDbl(fields(0)) * scaling
    y = CDbl(fields(1)) * scaling
    w = CDbl(fields(2)) * scaling
    h = CDbl(fields(3)) * scaling
    Set import_rect_centre = ActiveLayer.CreateRectangle2(x, y, w, h)
End Function

Function import_lines(ts, scaling As Double) As Shape

    Dim sub_path_closed As Boolean
    sub_path_closed = False
    Dim sub_path_created As Boolean
    sub_path_created = False
    Dim count_segments As Integer
    count_segments = 0
    
    Dim crv As Curve
    Set crv = Application.CreateCurve(ActiveDocument)
    
   
    Dim sp As SubPath


    Dim str As String
    Do While ts.atendofstream <> True
        str = ts.ReadLine
        
        'begin_path
        '   not necessary for first path
        'comments
        If Left(str, 1) = "#" Then
        
        ElseIf str = "begin_new_path" Then
            If sub_path_created Then
                sp.Closed = sub_path_closed
                sub_path_created = False
            End If
        'close
        '   path is closed
        ElseIf str = "path_is_closed" Then
            sub_path_closed = True
        'open
        '   path is closed
        ElseIf str = "path_is_open" Then
            sub_path_closed = False
        'end_line
        ElseIf str = "end_line" Then
            Exit Do
        
        ' data
        Else
            Dim fields As Variant
            fields = Split(str, Chr(9))
            If Not UBound(fields) = 1 Then
                MsgBox ("Warning:[" & str & "] needs to have two XY values")
                Error 321
            End If
            Dim x As Double, y As Double
            x = CDbl(fields(0)) * scaling
            y = CDbl(fields(1)) * scaling
            If Not sub_path_created Then
                Set sp = crv.CreateSubPath(x, y)
            Else
                sp.AppendLineSegment x, y, False
            End If
            sub_path_created = True
                
        End If
    Loop
    sp.Closed = sub_path_closed
    Dim s As Shape
    Set s = ActiveLayer.CreateCurve(crv)
    Set import_lines = s
End Function

Sub import_stroke_rgb_and_apply(curr_shape As Shape, ts)
    Dim r As Integer, g As Integer, b As Integer
    import_rgb ts, r, g, b
    If Not curr_shape Is Nothing Then
        curr_shape.Outline.color.RGBAssign r, g, b
        'MsgBox ("stroke_rgb:" & r & ":" & g & ":" & _b)
    Else
        MsgBox ("Warning: No current Object")
    End If
End Sub

Sub import_fill_rgb_and_apply(curr_shape As Shape, ts)
    Dim r As Integer, g As Integer, b As Integer
    import_rgb ts, r, g, b
    If Not curr_shape Is Nothing Then
        curr_shape.Fill.UniformColor.RGBAssign r, g, b
        'MsgBox ("fill_rgb:" & r & ":" & g & ":" & _b)
    Else
        MsgBox ("Warning: No current Object")
    End If
End Sub

Sub Import_meta_data(FileName As String)
    
    ' get scale factor (1.0 = lesser of page dimensions)
    ActiveDocument.Unit = cdrMillimeter
    Dim ap As Page
    Dim scale_x As Double, scale_y As Double
    ActivePage.GetSize scale_x, scale_y
    Dim scaling As Double
    If scale_x < scale_y Then
        scaling = scale_x
    Else
        scaling = scale_y
    End If
    
    
    'text stream
    Dim fs, f, ts
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(FileName)
    Set ts = f.OpenAsTextStream(1, -2)
    
    
    ' grouping
    Dim group As New ShapeRange
    Dim is_grouping As Boolean
    is_grouping = False
    
    ' curr_shape
    Dim curr_shape As Shape
    
    ' deselect all
    ActiveDocument.ClearSelection


    
    Dim str
    Do While ts.atendofstream <> True
        str = ts.ReadLine
        
       
        'comments
        If Left(str, 1) = "#" Or Len(str) = 0 Then
        
        ' stroke_colour
        ElseIf str = "stroke_rgb" Then
            import_stroke_rgb_and_apply curr_shape, ts
        
        ' fill colour
        ElseIf str = "fill_rgb" Then
            import_fill_rgb_and_apply curr_shape, ts
        
        
        ' fill postscript
        ElseIf str = "fill_postscript" Then
            import_postscript_fill_and_apply curr_shape, ts
            
        ' no_fill
        ElseIf str = "fill_none" Then
            If Not curr_shape Is Nothing Then
                curr_shape.Fill.ApplyNoFill
            Else
                MsgBox ("Warning: No current Object")
            End If
        
        
        ' no_stroke
        ElseIf str = "stroke_none" Then
            If Not curr_shape Is Nothing Then
                curr_shape.Outline.Type = cdrNoOutline
            Else
                MsgBox ("Warning: No current Object")
            End If
        
        ' stroke width
        ElseIf str = "stroke_width" Then
            Dim stroke_width As Double
            stroke_width = import_float(ts)
            If Not curr_shape Is Nothing Then
                curr_shape.Outline.Width = stroke_width
            Else
                MsgBox ("Warning: No current Object")
            End If
            'MsgBox ("stroke_width:" & stroke_width)
            
        '
        '   name
        '
        ElseIf str = "name" Then
            If Not curr_shape Is Nothing Then
                curr_shape.Name = import_string(ts)
            Else
                MsgBox ("Warning: No current Object to name")
            End If
            
        
        
        ' lines
        ElseIf str = "begin_line" Then
            Set curr_shape = import_lines(ts, scaling)
            'MsgBox ("lines:")
            If is_grouping Then
                group.Add curr_shape
            End If
        
        
        '
        '   rectangles
        '
        ElseIf str = "rect_ltrb" Then
            Set curr_shape = import_rect_ltrb(ts, scaling)
            'MsgBox ("lines:")
            If is_grouping Then
                group.Add curr_shape
            End If
        ElseIf str = "rect_centre" Then
            Set curr_shape = import_rect_centre(ts, scaling)
            'MsgBox ("lines:")
            If is_grouping Then
                group.Add curr_shape
            End If
        
        
        '
        '   ellipses
        '
        ElseIf str = "ellipse_ltrb" Then
            Set curr_shape = import_ellipse_ltrb(ts, scaling)
            'MsgBox ("lines:")
            If is_grouping Then
                group.Add curr_shape
            End If
        ElseIf str = "ellipse_centre" Then
            Set curr_shape = import_ellipse_centre(ts, scaling)
            'MsgBox ("lines:")
            If is_grouping Then
                group.Add curr_shape
            End If
        
        
        
        ' begin group
        ElseIf str = "begin_group" Then
            If is_grouping Then
                MsgBox ("Warning: end_group first before beginning another group")
            End If
            is_grouping = True
            group.RemoveAll
            'MsgBox ("begin group")
        
        ' end group
        ElseIf str = "end_group" Then
            If Not is_grouping Then
                MsgBox ("Warning: begin group first before end_group")
            Else
                is_grouping = False
                If group.Count = 0 Then
                    MsgBox ("Warning: This group is empty")
                
                ' Only group if something in group
                ElseIf group.Count > 1 Then
                    'MsgBox ("end group")
                    ActiveDocument.ClearSelection
                    group.AddToSelection
                    Set curr_shape = Application.ActiveSelection.group
                    curr_shape.RemoveFromSelection
                End If
            End If
        Else
            MsgBox ("Warning:[" & str & "] is not a valid command")
            Error 321
        End If
    Loop
End Sub
    
    
Sub import_meta_commands()
    'd_meta_file.efile_name = "c:\cdr.test.delete.this"
    d_meta_file.Show
    

    Import_meta_data (d_meta_file.efile_name)
End Sub
